home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr52 / achoice.zip / TEST.PRG < prev   
Text File  |  1993-04-01  |  4KB  |  135 lines
  1.  
  2. * Program..: TEST.PRG
  3. * Author...: Harry F. Gilbert
  4. * Date.....: 2/9/88
  5. * Purpose..: Test ACHOICE() in Clipper S'87 Compiler
  6. * Notes....: Thanks to Harry Van Tassell for definition of "standard colors"
  7.  
  8. PUBLIC StdVideo,RevVideo,BorVideo,UlineVideo 
  9. PUBLIC BriteVideo,BlinkVideo,NoSelVideo      
  10. PUBLIC m_file,m_ndx,m_fld,m_prompt,m_alias 
  11.  
  12. * Define "standard colors"
  13. StdVideo   = "GR+/B"     && Yellow/Blue
  14. RevVideo   = "W/R"       && White/Red
  15. BorVideo   = "B"         && Blue
  16. UlineVideo = "W+/B"      && Brite White/Blue
  17. BriteVideo = "BG+/B"     && Brite Cyan/Blue
  18. BlinkVideo = "W*/R"      && Blink White/Red
  19. NoSelVideo = "R/W"       && Red/White
  20. AllVideo = StdVideo+","+RevVideo+","+BorVideo+",,"+NoSelVideo
  21. SET COLOR TO &AllVideo
  22.  
  23. DO Newscreen WITH "TEST PROGRAM","001"
  24.  
  25. m_file = "ORG"
  26. m_ndx  = "ORG"
  27. m_fld  = "Org_No"
  28. m_alias = "ORG"
  29.  
  30. IF FILE("&m_file..NTX")
  31.   USE &m_file INDEX &m_ndx ALIAS &m_alias
  32. ELSE
  33.   DO Window1 WITH "Indexing " + m_file + " file","Please Be Patient"
  34.   USE &m_file ALIAS &m_alias
  35.   INDEX ON &m_fld TO &m_ndx
  36. ENDIF
  37. GO TOP                        && S'87 indexing leaves file pointer at EOF()
  38.  
  39. orglist = ""
  40.  
  41. DECLARE A1[Reccount()]        && Array of Organization Numbers
  42.  
  43. FOR i = 1 TO Reccount()       && Fill Org Number array
  44.   A1[i] = "  " + LTRIM(RTRIM(STR(Org->Org_No,6)))
  45.   SKIP
  46. NEXT
  47.  
  48. menuchoice = 1                && Initialize menuchoice
  49. relative   = 0                && Initial relative window row
  50.  
  51. @ 9,29 TO 16,36 DOUBLE        && Draw a box
  52.  
  53. DO WHILE menuchoice <> 0
  54.   menuchoice = ACHOICE(10,30,15,35,A1,.T.,"Rules",menuchoice,relative)
  55.   IF menuchoice = 0           && <ESC> was pressed; leave loop
  56.     EXIT
  57.   ENDIF
  58.   * Now toggle selected marker when <Enter> was pressed
  59.   A1[menuchoice] = IIF(SUBSTR(A1[menuchoice],1,1)=" ",;
  60.                    "* "+SUBSTR(A1[menuchoice],3),"  "+SUBSTR(A1[menuchoice],3))
  61. ENDDO
  62.  
  63. FOR i = 1 TO Reccount()      && Create list of selected organizations
  64.   IF SUBSTR(A1[i],1,1) = "*"
  65.     orglist = orglist + SUBSTR(A1[i],3) + ","
  66.   ENDIF
  67. NEXT
  68.  
  69. Orglist = SUBSTR(Orglist,1,LEN(Orglist)-1)  && Remove trailing comma
  70.  
  71. @ 20,5
  72. @ 20,5 SAY "Orgs Chosen are: " + Orglist
  73. CLOSE DATABASES
  74. CLEAR ALL
  75. RETURN
  76. QUIT
  77.  
  78.  
  79.  
  80. FUNCTION Rules                          && The UDF used by ACHOICE()
  81. PARAMETERS mode,element,position        && Passed by ACHOICE()
  82. DO CASE
  83.   CASE lastkey() = 27
  84.     reply = 0
  85.   CASE lastkey() = 13
  86.     reply = 1
  87.   OTHERWISE
  88.     reply = 2
  89. ENDCASE
  90. relative = position
  91. RETURN (reply)
  92.  
  93.  
  94. PROCEDURE Newscreen                    && My "standard" screen
  95. PARAMETERS banner,snum
  96. CLEAR
  97. @  1, 0 SAY TRIM(Banner)
  98. IF EMPTY(snum)
  99.   @ 1,72 SAY DTOC(date())
  100. ELSE
  101.   @ 1,72 SAY "[ "+TRIM(snum)+" ]"      && A "screen number" for help reference
  102. ENDIF
  103. @  2, 0 SAY REPLICATE(CHR(205),80)
  104. @ 19, 0 SAY REPLICATE(CHR(196),80)
  105. RETURN
  106. * EOP: newscreen
  107.  
  108. PROCEDURE Window1                     && Pop-up window, remains on screen for
  109. PRIVATE msg1,msg2                     &&   10 seconds or until key is pressed  
  110. STORE " " TO msg1,msg2
  111. IF PCOUNT() = 1                       && How many message lines were passed?
  112.   PARAMETERS msg1
  113. ELSE
  114.   PARAMETERS msg1,msg2
  115. ENDIF
  116. SAVE SCREEN
  117. SET COLOR TO &RevVideo
  118. SET CURSOR OFF
  119. @ 6,10 CLEAR TO 16,69
  120. @ 6,10 TO 16,69 DOUBLE
  121. @ 9,(40-INT(LEN(msg1)/2)) SAY msg1
  122. IF .NOT. EMPTY(msg2)
  123.   @ 11,(40-INT(LEN(msg2)/2)) SAY msg2
  124. ENDIF
  125. TONE(800,5)
  126. TONE(400,5)
  127. mtime = INKEY(10)
  128. SET COLOR TO &StdVideo
  129. RESTORE SCREEN
  130. SET CURSOR ON
  131. RELEASE mtime,msg1,msg2
  132. RETURN
  133. * EOP: window1
  134.  
  135.